home *** CD-ROM | disk | FTP | other *** search
/ Celestin Apprentice 7 / Apprentice-Release7.iso / Source Code / C / Applications / Tcl-Tk 8.0 / Pre-installed version / tcl8.0 / tests / var.test < prev    next >
Encoding:
Text File  |  1997-08-15  |  14.9 KB  |  468 lines  |  [TEXT/ALFA]
  1. # This file contains tests for the tclVar.c source file. Tests appear in
  2. # the same order as the C code that they test. The set of tests is
  3. # currently incomplete since it currently includes only new tests for
  4. # code changed for the addition of Tcl namespaces. Other variable-
  5. # related tests appear in several other test files including
  6. # namespace.test, set.test, trace.test, and upvar.test.
  7. #
  8. # Sourcing this file into Tcl runs the tests and generates output for
  9. # errors. No output means no errors were found.
  10. #
  11. # Copyright (c) 1997 Sun Microsystems, Inc.
  12. #
  13. # See the file "license.terms" for information on usage and redistribution
  14. # of this file, and for a DISCLAIMER OF ALL WARRANTIES.
  15. #
  16. # SCCS: @(#) var.test 1.10 97/07/28 18:31:47
  17. #
  18.  
  19. if {[string compare test [info procs test]] == 1} then {source defs}
  20.  
  21. catch {rename p ""}
  22. catch {namespace delete test_ns_var}
  23. catch {unset xx}
  24. catch {unset x}
  25. catch {unset y}
  26. catch {unset i}
  27. catch {unset a}
  28. catch {unset arr}
  29.  
  30. test var-1.1 {TclLookupVar, TCL_PARSE_PART1 flag set} {
  31.     catch {unset a}
  32.     set x "incr"  ;# force no compilation and runtime call to Tcl_IncrCmd 
  33.     set i 10
  34.     set arr(foo) 37
  35.     list [$x i] $i [$x arr(foo)] $arr(foo)
  36. } {11 11 38 38}
  37. test var-1.2 {TclLookupVar, TCL_GLOBAL_ONLY implies global namespace var} {
  38.     set x "global value"
  39.     namespace eval test_ns_var {
  40.         variable x "namespace value"
  41.         proc p {} {
  42.             global x  ;# specifies TCL_GLOBAL_ONLY to get global x
  43.             return $x
  44.         }
  45.     }
  46.     test_ns_var::p
  47. } {global value}
  48. test var-1.3 {TclLookupVar, TCL_NAMESPACE_ONLY implies namespace var} {
  49.     namespace eval test_ns_var {
  50.         proc q {} {
  51.             variable x  ;# specifies TCL_NAMESPACE_ONLY to get namespace x
  52.             return $x
  53.         }
  54.     }
  55.     test_ns_var::q
  56. } {namespace value}
  57. test var-1.4 {TclLookupVar, no active call frame implies global namespace var} {
  58.     set x
  59. } {global value}
  60. test var-1.5 {TclLookupVar, active call frame pushed for namespace eval implies namespace var} {
  61.     namespace eval test_ns_var {set x}
  62. } {namespace value}
  63. test var-1.6 {TclLookupVar, name starts with :: implies some namespace var} {
  64.     namespace eval test_ns_var {set ::x}
  65. } {global value}
  66. test var-1.7 {TclLookupVar, error finding namespace var} {
  67.     list [catch {set a:::b} msg] $msg
  68. } {1 {can't read "a:::b": no such variable}}
  69. test var-1.8 {TclLookupVar, error finding namespace var} {
  70.     list [catch {set ::foobarfoo} msg] $msg
  71. } {1 {can't read "::foobarfoo": no such variable}}
  72. test var-1.9 {TclLookupVar, create new namespace var} {
  73.     namespace eval test_ns_var {
  74.         set v hello
  75.     }
  76. } {hello}
  77. test var-1.10 {TclLookupVar, create new namespace var} {
  78.     catch {unset y}
  79.     namespace eval test_ns_var {
  80.         set ::y 789
  81.     }
  82.     set y
  83. } {789}
  84. test var-1.11 {TclLookupVar, error creating new namespace var} {
  85.     namespace eval test_ns_var {
  86.         list [catch {set ::test_ns_var::foo::bar 314159} msg] $msg
  87.     }
  88. } {1 {can't set "::test_ns_var::foo::bar": parent namespace doesn't exist}}
  89. test var-1.12 {TclLookupVar, error creating new namespace var} {
  90.     namespace eval test_ns_var {
  91.         list [catch {set ::test_ns_var::foo:: 1997} msg] $msg
  92.     }
  93. } {1 {can't set "::test_ns_var::foo::": parent namespace doesn't exist}}
  94. test var-1.13 {TclLookupVar, new namespace var is created in a particular namespace} {
  95.     catch {unset aNeWnAmEiNnS}
  96.     namespace eval test_ns_var {
  97.         namespace eval test_ns_var2::test_ns_var3 {
  98.             set aNeWnAmEiNnS 77777
  99.         }
  100.         # namespace which builds a name by traversing nsPtr chain to ::
  101.         namespace which -variable test_ns_var2::test_ns_var3::aNeWnAmEiNnS
  102.     }
  103. } {::test_ns_var::test_ns_var2::test_ns_var3::aNeWnAmEiNnS}
  104. test var-1.14 {TclLookupVar, namespace code ignores ":"s in middle and end of var names} {
  105.     namespace eval test_ns_var {
  106.         set : 123
  107.         set v: 456
  108.         set x:y: 789
  109.         list [set :] [set v:] [set x:y:] \
  110.              ${:} ${v:} ${x:y:} \
  111.              [expr {[lsearch [info vars] :] != -1}] \
  112.              [expr {[lsearch [info vars] v:] != -1}] \
  113.              [expr {[lsearch [info vars] x:y:] != -1}]
  114.     }
  115. } {123 456 789 123 456 789 1 1 1}
  116.  
  117. test var-2.1 {Tcl_LappendObjCmd, create var if new} {
  118.     catch {unset x}
  119.     lappend x 1 2
  120. } {1 2}
  121.  
  122. test var-3.1 {MakeUpvar, TCL_NAMESPACE_ONLY not specified for other var} {
  123.     catch {unset x}
  124.     set x 1997
  125.     proc p {} {
  126.         global x  ;# calls MakeUpvar with TCL_NAMESPACE_ONLY for other var x
  127.         return $x
  128.     }
  129.     p
  130. } {1997}
  131. test var-3.2 {MakeUpvar, other var has TCL_NAMESPACE_ONLY specified} {
  132.     namespace eval test_ns_var {
  133.         catch {unset v}
  134.         variable v 1998
  135.         proc p {} {
  136.             variable v  ;# TCL_NAMESPACE_ONLY specified for other var x
  137.             return $v
  138.         }
  139.         p
  140.     }
  141. } {1998}
  142. if {[info commands testupvar] != {}} {
  143.     test var-3.3 {MakeUpvar, my var has TCL_GLOBAL_ONLY specified} {
  144.         catch {unset a}
  145.         set a 123321
  146.         proc p {} {
  147.             # create global xx linked to global a
  148.         testupvar 1 a {} xx global 
  149.     }
  150.         list [p] $xx [set xx 789] $a
  151.     } {{} 123321 789 789}
  152.     test var-3.4 {MakeUpvar, my var has TCL_NAMESPACE_ONLY specified} {
  153.         catch {unset a}
  154.         set a 456
  155.         namespace eval test_ns_var {
  156.             catch {unset ::test_ns_var::vv}
  157.             proc p {} {
  158.                 # create namespace var vv linked to global a
  159.             testupvar 1 a {} vv namespace 
  160.         }
  161.             p
  162.         }
  163.         list $test_ns_var::vv [set test_ns_var::vv 123] $a
  164.     } {456 123 123}
  165. }
  166. test var-3.5 {MakeUpvar, no call frame so my var will be in global :: ns} {
  167.     catch {unset aaaaa}
  168.     catch {unset xxxxx}
  169.     set aaaaa 77777
  170.     upvar #0 aaaaa xxxxx
  171.     list [set xxxxx] [set aaaaa]
  172. } {77777 77777}
  173. test var-3.6 {MakeUpvar, active call frame pushed for namespace eval} {
  174.     catch {unset a}
  175.     set a 121212
  176.     namespace eval test_ns_var {
  177.         upvar ::a vvv
  178.         set vvv
  179.     }
  180. } {121212}
  181. test var-3.7 {MakeUpvar, my var has ::s} {
  182.     catch {unset a}
  183.     set a 789789
  184.     upvar #0 a test_ns_var::lnk
  185.     namespace eval test_ns_var {
  186.         set lnk
  187.     }
  188. } {789789}
  189. test var-3.8 {MakeUpvar, my var already exists in global ns} {
  190.     catch {unset aaaaa}
  191.     catch {unset xxxxx}
  192.     set aaaaa 456654
  193.     set xxxxx hello
  194.     upvar #0 aaaaa xxxxx
  195.     set xxxxx
  196. } {hello}
  197. test var-3.9 {MakeUpvar, my var has invalid ns name} {
  198.     catch {unset aaaaa}
  199.     set aaaaa 789789
  200.     list [catch {upvar #0 aaaaa test_ns_fred::lnk} msg] $msg
  201. } {1 {bad variable name "test_ns_fred::lnk": unknown namespace}}
  202.  
  203. if {[info commands testgetvarfullname] != {}} {
  204.     test var-4.1 {Tcl_GetVariableName, global variable} {
  205.         catch {unset a}
  206.         set a 123
  207.         testgetvarfullname a global
  208.     } ::a
  209.     test var-4.2 {Tcl_GetVariableName, namespace variable} {
  210.         namespace eval test_ns_var {
  211.             variable george
  212.             testgetvarfullname george namespace
  213.         }
  214.     } ::test_ns_var::george
  215.     test var-4.3 {Tcl_GetVariableName, variable can't be array element} {
  216.         catch {unset a}
  217.         set a(1) foo
  218.         list [catch {testgetvarfullname a(1) global} msg] $msg
  219.     } {1 {unknown variable "a(1)"}}
  220. }
  221.  
  222. test var-5.1 {Tcl_GetVariableFullName, global variable} {
  223.     catch {unset a}
  224.     set a bar
  225.     namespace which -variable a
  226. } {::a}
  227. test var-5.2 {Tcl_GetVariableFullName, namespace variable} {
  228.     namespace eval test_ns_var {
  229.         variable martha
  230.         namespace which -variable martha
  231.     }
  232. } {::test_ns_var::martha}
  233. test var-5.3 {Tcl_GetVariableFullName, namespace variable} {
  234.     namespace which -variable test_ns_var::martha
  235. } {::test_ns_var::martha}
  236.  
  237. test var-6.1 {Tcl_GlobalObjCmd, variable is qualified by a namespace name} {
  238.     namespace eval test_ns_var {
  239.         variable boeing 777
  240.     }
  241.     proc p {} {
  242.         global ::test_ns_var::boeing
  243.         set boeing
  244.     }
  245.     p
  246. } {777}
  247. test var-6.2 {Tcl_GlobalObjCmd, variable is qualified by a namespace name} {
  248.     namespace eval test_ns_var {
  249.         namespace eval test_ns_nested {
  250.             variable java java
  251.         }
  252.         proc p {} {
  253.             global ::test_ns_var::test_ns_nested::java
  254.             set java
  255.         }
  256.     }
  257.     test_ns_var::p
  258. } {java}
  259. test var-6.3 {Tcl_GlobalObjCmd, variable named {} qualified by a namespace name} {
  260.     set ::test_ns_var::test_ns_nested:: 24
  261.     proc p {} {
  262.         global ::test_ns_var::test_ns_nested::
  263.         set {}
  264.     }
  265.     p
  266. } {24}
  267.  
  268. test var-7.1 {Tcl_VariableObjCmd, create and initialize one new ns variable} {
  269.     catch {namespace delete test_ns_var}
  270.     namespace eval test_ns_var {
  271.         variable one 1
  272.     }
  273.     list [info vars test_ns_var::*] [set test_ns_var::one]
  274. } {::test_ns_var::one 1}
  275. test var-7.2 {Tcl_VariableObjCmd, if new and no value, leave undefined} {
  276.     set two 2222222
  277.     namespace eval test_ns_var {
  278.         variable two
  279.     }
  280.     list [info exists test_ns_var::two] [catch {set test_ns_var::two} msg] $msg
  281. } {0 1 {can't read "test_ns_var::two": no such variable}}
  282. test var-7.3 {Tcl_VariableObjCmd, "define" var already created above} {
  283.     namespace eval test_ns_var {
  284.         variable two 2
  285.     }
  286.     list [info vars test_ns_var::*] \
  287.          [namespace eval test_ns_var {set two}]
  288. } {{::test_ns_var::two ::test_ns_var::one} 2}
  289. test var-7.4 {Tcl_VariableObjCmd, list of vars} {
  290.     namespace eval test_ns_var {
  291.         variable three 3 four 4
  292.     }
  293.     list [info vars test_ns_var::*] \
  294.          [namespace eval test_ns_var {expr $three+$four}]
  295. } {{::test_ns_var::four ::test_ns_var::three ::test_ns_var::two ::test_ns_var::one} 7}
  296. test var-7.5 {Tcl_VariableObjCmd, value for last var is optional} {
  297.     catch {unset a}
  298.     catch {unset five}
  299.     catch {unset six}
  300.     set a ""
  301.     set five 555
  302.     set six  666
  303.     namespace eval test_ns_var {
  304.         variable five 5 six
  305.         lappend a $five
  306.     }
  307.     lappend a $test_ns_var::five \
  308.         [set test_ns_var::six 6] [set test_ns_var::six] $six
  309.     catch {unset five}
  310.     catch {unset six}
  311.     set a
  312. } {5 5 6 6 666}
  313. catch {unset newvar}
  314. test var-7.6 {Tcl_VariableObjCmd, variable name can be qualified} {
  315.     namespace eval test_ns_var {
  316.         variable ::newvar cheers!
  317.     }
  318.     set newvar
  319. } {cheers!}
  320. catch {unset newvar}
  321. test var-7.7 {Tcl_VariableObjCmd, bad var name} {
  322.     namespace eval test_ns_var {
  323.         list [catch {variable sev:::en 7} msg] $msg
  324.     }
  325. } {1 {can't define "sev:::en": parent namespace doesn't exist}}
  326. test var-7.8 {Tcl_VariableObjCmd, if var already exists and no value is given, leave value unchanged} {
  327.     set a ""
  328.     namespace eval test_ns_var {
  329.         variable eight 8
  330.         lappend a $eight
  331.         variable eight
  332.         lappend a $eight
  333.     }
  334.     set a
  335. } {8 8}
  336. test var-7.9 {Tcl_VariableObjCmd, mark as namespace var so var persists until namespace is destroyed or var is unset} {
  337.     catch {namespace delete test_ns_var2}
  338.     set a ""
  339.     namespace eval test_ns_var2 {
  340.         variable x 123
  341.         variable y
  342.         variable z
  343.     }
  344.     lappend a [info vars test_ns_var2::*]
  345.     lappend a [info exists test_ns_var2::x] [info exists test_ns_var2::y] \
  346.         [info exists test_ns_var2::z]
  347.     lappend a [list [catch {set test_ns_var2::y} msg] $msg]
  348.     lappend a [info vars test_ns_var2::*]
  349.     lappend a [info exists test_ns_var2::y] [info exists test_ns_var2::z]
  350.     lappend a [set test_ns_var2::y hello]
  351.     lappend a [info exists test_ns_var2::y] [info exists test_ns_var2::z]
  352.     lappend a [list [catch {unset test_ns_var2::y} msg] $msg]
  353.     lappend a [info vars test_ns_var2::*]
  354.     lappend a [info exists test_ns_var2::y] [info exists test_ns_var2::z]
  355.     lappend a [list [catch {unset test_ns_var2::z} msg] $msg]
  356.     lappend a [namespace delete test_ns_var2]
  357.     set a
  358. } {{::test_ns_var2::x ::test_ns_var2::y ::test_ns_var2::z} 1 0 0\
  359. {1 {can't read "test_ns_var2::y": no such variable}}\
  360. {::test_ns_var2::x ::test_ns_var2::y ::test_ns_var2::z} 0 0\
  361. hello 1 0\
  362. {0 {}}\
  363. {::test_ns_var2::x ::test_ns_var2::z} 0 0\
  364. {1 {can't unset "test_ns_var2::z": no such variable}}\
  365. {}}
  366. test var-7.10 {Tcl_VariableObjCmd, variable cmd inside proc creates local link var} {
  367.     namespace eval test_ns_var {
  368.         proc p {} {
  369.             variable eight
  370.             list [set eight] [info vars]
  371.         }
  372.         p
  373.     }
  374. } {8 eight}
  375. test var-7.11 {Tcl_VariableObjCmd, variable cmd inside proc creates local link var} {
  376.     proc p {} {   ;# note this proc is at global :: scope
  377.         variable test_ns_var::eight
  378.         list [set eight] [info vars]
  379.     }
  380.     p
  381. } {8 eight}
  382. test var-7.12 {Tcl_VariableObjCmd, variable cmd inside proc creates local link var} {
  383.     namespace eval test_ns_var {
  384.         variable {} {My name is empty}
  385.     }
  386.     proc p {} {   ;# note this proc is at global :: scope
  387.         variable test_ns_var::
  388.         list [set {}] [info vars]
  389.     }
  390.     p
  391. } {{My name is empty} {{}}}
  392.  
  393. test var-8.1 {TclDeleteVars, "unset" traces are called with fully-qualified var names} {
  394.     catch {namespace delete test_ns_var}
  395.     catch {unset a}
  396.     namespace eval test_ns_var {
  397.         variable v 123
  398.         variable info ""
  399.  
  400.         proc traceUnset {name1 name2 op} {
  401.             variable info
  402.             set info [concat $info [list $name1 $name2 $op]]
  403.         }
  404.  
  405.         trace var v u [namespace code traceUnset]
  406.     }
  407.     list [unset test_ns_var::v] $test_ns_var::info
  408. } {{} {test_ns_var::v {} u}}
  409.  
  410. test var-9.1 {behaviour of TclSetVar without TCL_LEAVE_ERR_MSG flag} {
  411.     testsetnoerr v 1
  412. } 1
  413. test var-9.2 {behaviour of TclGetVar without TCL_LEAVE_ERR_MSG flag} {
  414.     catch {unset v}
  415.     list [catch {testsetnoerr v} res] $res;
  416. } {1 {before get}}
  417. test var-9.3 {behaviour of TclGetVar without TCL_LEAVE_ERR_MSG flag} {
  418.     catch {unset arr}
  419.     set arr(1) 1;
  420.     list [catch {testsetnoerr arr} res] $res;
  421. } {1 {before get}}
  422. test var-9.4 {behaviour of TclGetVar without TCL_LEAVE_ERR_MSG flag} {
  423.     namespace eval ns {variable v nsv}
  424.     testsetnoerr ns::v;
  425. } nsv;
  426. test var-9.5 {behaviour of TclGetVar without TCL_LEAVE_ERR_MSG flag} {
  427.     catch {namespace delete ns}
  428.     list [catch {testsetnoerr ns::v} res] $res;
  429. } {1 {before get}}
  430. test var-9.6 {behaviour of TclSetVar without TCL_LEAVE_ERR_MSG flag} {
  431.     catch {unset arr}
  432.     set arr(1) 1;
  433.     list [catch {testsetnoerr arr 2} res] $res;
  434. } {1 {before set}}
  435. test var-9.7 {behaviour of TclSetVar without TCL_LEAVE_ERR_MSG flag} {
  436.     catch {unset arr}
  437.     set arr(1) 1;
  438.     list [catch {testsetnoerr arr 2} res] $res;
  439. } {1 {before set}}
  440. test var-9.8 {behaviour of TclSetVar without TCL_LEAVE_ERR_MSG flag} {
  441.     # this test currently fails, should not...
  442.     # (some namespace function resets the interp while it should not)
  443.     catch {namespace delete ns}
  444.     list [catch {testsetnoerr ns::v 1} res] $res;
  445. } {1 {before set}}
  446. test var-9.9 {behaviour of TclSetVar without TCL_LEAVE_ERR_MSG flag} {
  447.     proc readonly args {error "read-only"}
  448.     set v 456
  449.     trace var v w readonly
  450.     list [catch {testsetnoerr v 2} msg] $msg
  451. } {1 {before set}}
  452.  
  453. catch {namespace delete ns}
  454. catch {unset arr}
  455. catch {unset v}
  456.  
  457. catch {rename p ""}
  458. catch {namespace delete test_ns_var}
  459. catch {namespace delete test_ns_var2}
  460. catch {unset xx}
  461. catch {unset x}
  462. catch {unset y}
  463. catch {unset i}
  464. catch {unset a}
  465. catch {unset xxxxx}
  466. catch {unset aaaaa}
  467.  
  468.